home *** CD-ROM | disk | FTP | other *** search
/ Games of Daze / Infomagic - Games of Daze (Summer 1995) (Disc 1 of 2).iso / x2ftp / msdos / source / 1svga / gr_demo.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-05-07  |  10.4 KB  |  369 lines
  1. {┌────────────────────────────────────────────╖
  2.  │   ▄▄▄▄▄  ▄▄▄▄▄                             ║
  3.  │  █▒      █▒   █▒  SVGA/VESA Graph Demo     ║
  4.  │  █▒  ▀█▒ █▒▄▄▄▀   640x480--1024x768 256C   ║
  5.  │  █▒   █▒ █▒   █▒  Written by Jou-Nan Chen  ║
  6.  │   ▀▀▀▀   ▀    ▀                            ║
  7.  ╘════════════════════════════════════════════╝}
  8.  
  9. uses Crt,Graph,Txt;
  10.  
  11. const Name:array[0..9] of string[8]=(
  12.     'Line1','Line2' ,'Line3' ,'Line4', 'Line5',
  13.     'Rose' ,'Dough1','Dough2','Mirror','Flowers');
  14. var Ratio:real;    { 1=640, 1.25=800, 1.6=1024 }
  15.     Pal:array[0..767] of byte;
  16.  
  17. { ─────────────── Graph1 ─────────────── }
  18. procedure Graph1(Xc,Yc,Xr,Yr:integer);
  19. var X0,Y0,X1,Y1,I,X,Y:integer;
  20.     A,M:real;
  21. begin
  22.   A:=0; X:=Trunc(Xr*0.4); Y:=Trunc(Yr*0.4);
  23.   for I:=0 to 800 do begin
  24.     X0:=Xc+Trunc(Xr*Cos(A));
  25.     Y0:=Yc+Trunc(Yr*Sin(5*A)*Cos(A/1.5));
  26.     M:=Sin(A);
  27.     X1:=Trunc(X*M);
  28.     Y1:=Trunc(Y*M);
  29.     SetColor(I div 12+32);
  30.     Line(X0,Y0,X0+X1,Y0+Y1);
  31.     Line(X0,Y0,X0+X1,Y0-Y1);
  32.     A:=A+Pi/400;
  33.   end;
  34. end;
  35. { ─────────────── Graph2 ─────────────── }
  36. procedure Graph2(Xc,Yc,Xr,Yr:integer);
  37. var X1,Y1,X2,Y2,I:integer;
  38.     A,M,N:real;
  39. begin
  40.   A:=0;
  41.   for I:=0 to 500 do begin
  42.     M:=Sin(A); N:=Cos(A);
  43.     X1:=Xc+Trunc(1.2*(Xr+Xr/3*(1+0.5*Cos(12*A))*N)*N);
  44.     X2:=Xc+Trunc(1.2*(Yr+Yr/3*(1+0.5*Sin(12*A))*N)*N);
  45.     Y1:=Yc-Trunc((Xr+Xr/3*(1+0.5*Cos(10*A))*M)*M);
  46.     Y2:=Yc-Trunc((Yr+Yr/2*(1+0.5*Cos(15*A))*M)*M);
  47.     SetColor(I div 7+32);
  48.     Line(X1,Y1,X2,Y2);
  49.     A:=A+Pi/250;
  50.   end;
  51. end;
  52. { ─────────────── Graph3 ─────────────── }
  53. procedure Graph3(Xc,Yc,R:integer);
  54. var X1,Y1,X2,Y2,I:integer;
  55.     A,F:real;
  56. begin
  57.   A:=0;
  58.   for I:=0 to 1600 do begin
  59.     F:=R*(1+0.25*Cos(20*A))*(1+Sin(4*A));
  60.     X1:=Xc+Trunc(F*Cos(A));
  61.     X2:=Xc+Trunc(F*Cos(A+Pi/5));
  62.     Y1:=Yc-Trunc(F*Sin(A));
  63.     Y2:=Yc-Trunc(F*Sin(A+Pi/5));
  64.     SetColor(I div 23+32);
  65.     Line(X1,Y1,X2,Y2);
  66.     A:=A+Pi/800;
  67.   end;
  68. end;
  69. { ─────────────── Graph4 ─────────────── }
  70. procedure Graph4(Xc,Yc,R:integer);
  71. var X1,Y1,X2,Y2,I:integer;
  72.     A,F:real;
  73. begin
  74.   A:=0;
  75.   for I:=0 to 1600 do begin
  76.     F:=R*(1+0.25*Cos(4*A))*(1+Sin(8*A));
  77.     X1:=Xc+Trunc(F*Cos(A));
  78.     X2:=Xc+Trunc(F*Cos(A+Pi/8));
  79.     Y1:=Yc-Trunc(F*Sin(A));
  80.     Y2:=Yc-Trunc(F*Sin(A+Pi/8));
  81.     SetColor(I div 23+32);
  82.     Line(X1,Y1,X2,Y2);
  83.     A:=A+Pi/800;
  84.   end;
  85. end;
  86. { ─────────────── Graph5 ─────────────── }
  87. procedure Graph5(Xc,Yc,R:integer);
  88. var X1,Y1,X2,Y2,I:integer;
  89.     A,E:real;
  90. begin
  91.   A:=0;
  92.   for I:=0 to 800 do begin
  93.     E:=R*(1+0.5*Sin(2.5*A));
  94.     X1:=Xc+Trunc(E*Cos(A));
  95.     X2:=Xc+Trunc(E*Cos(A+Pi/4));
  96.     Y1:=Yc-Trunc(E*Sin(A));
  97.     Y2:=Yc-Trunc(E*Sin(A+Pi/4));
  98.     SetColor(I div 12+32);
  99.     Line(X1,Y1,X2,Y2);
  100.     A:=A+Pi/200;
  101.   end;
  102. end;
  103. { ─────────────── Graph6 ─────────────── }
  104. procedure Graph6(Xi,Yi,R,Xr,Yr:integer);
  105. var X,Y,N,P,K,I,Bx,By:integer;
  106.     A,E:real;
  107. begin
  108.   for N:=2 to 7 do
  109.     for P:=1 to 6 do begin
  110.       if N mod 2=0 then K:=2 else K:=1;
  111.       A:=0; SetColor(6*N+P+48);
  112.       for I:=0 to 15*N*K do begin
  113.     E:=R/5*Sin(N*P*A)+R*Sin(N*A);
  114.     X:=Xr*(N-2)+Xi+Trunc(E*Cos(A));
  115.     Y:=Yr*(P-1)+Yi+Trunc(E*Sin(A));
  116.     if I=0 then begin MoveTo(X,Y); Bx:=X; By:=Y; end;
  117.     LineTo(X,Y);
  118.     A:=A+Pi/15/N;
  119.       end;
  120.       LineTo(Bx,By);
  121.     end;
  122. end;
  123. { ─────────────── Graph7 ─────────────── }
  124. procedure Graph7(Xc,Yc,R:integer);
  125. var XX,YY:array[1..120] of integer;
  126.     X,Px,Py,Bx,By,X1,Y1,X2,Y2,I:integer;
  127.     Th,A:real;
  128. begin
  129.   A:=0; X:=4*R;
  130.   for I:=1 to 120 do begin
  131.     Th:=66*Sqrt(Abs(Cos(3*A)))+12*Sqrt(Abs(Cos(9*A)));
  132.     XX[I]:=Trunc(Th*Cos(A)*1.2/320*R);
  133.     YY[I]:=Trunc(Th*Sin(A)/320*R);
  134.     A:=A+Pi/60;
  135.   end;
  136.   for Py:=1 to 2 do
  137.     for Px:=1 to 8 do begin
  138.       for I:=1 to 120 do begin
  139.     X1:=XX[I]+Px*R shr 1-R shr 2;
  140.     Y1:=YY[I]+Py*R shr 1-R shr 2;
  141.     Th:=2*Pi*(X-X1)/X;
  142.     X2:=Xc+Trunc(Y1*Cos(Th));
  143.     Y2:=Yc+Trunc(Y1*Sin(Th));
  144.     if I=1 then begin MoveTo(X2,Y2); Bx:=X2; By:=Y2; end;
  145.     SetColor((120*(2*Py+Px)+I) div 22+32);
  146.     LineTo(X2,Y2);
  147.       end;
  148.       LineTo(Bx,By);
  149.     end;
  150. end;
  151. { ─────────────── Graph8 ─────────────── }
  152. procedure Graph8(Xc,Yc,R:integer);
  153. var XX,YY:array[1..120] of integer;
  154.     X,Px,Py,Bx,By,X1,Y1,X2,Y2,I:integer;
  155.     Th,A,M,N:real;
  156. begin
  157.   A:=0; X:=4*R;
  158.   for I:=1 to 120 do begin
  159.     Th:=40*Sin(4*(A+Pi/8));
  160.     M:=Sin(A); N:=Cos(A);
  161.     XX[I]:=Trunc((Th*N+45*N*N*N)/320*R);
  162.     YY[I]:=Trunc((Th*M+45*M*M*M)/320*R);
  163.     A:=A+Pi/60;
  164.   end;
  165.   for Py:=1 to 2 do
  166.     for Px:=1 to 8 do begin
  167.       for I:=1 to 120 do begin
  168.     X1:=XX[I]+Px*R shr 1-R shr 2;
  169.     Y1:=YY[I]+Py*R shr 1-R shr 2;
  170.     Th:=2*Pi*(X-X1)/X;
  171.     X2:=Xc+Trunc(Y1*Cos(Th));
  172.     Y2:=Yc+Trunc(Y1*Sin(Th));
  173.     if I=1 then begin MoveTo(X2,Y2); Bx:=X2; By:=Y2; end;
  174.     SetColor((120*(2*Py+Px)+I) div 22+32);
  175.     LineTo(X2,Y2);
  176.       end;
  177.       LineTo(Bx,By);
  178.     end;
  179. end;
  180. { ─────────────── Graph9 ─────────────── }
  181. procedure Graph9(Xc,Yc,D,R:integer);
  182. var XX,YY:array[1..120] of integer;
  183.     D2,Un,Uv,K,S,X,Y,Px,Py,Bx,By,I,Sq:longint;
  184.     Th,Sc,A,M:real;
  185. begin
  186.   A:=0; Un:=12; Uv:=D div Un; K:=Uv div 2; Sc:=Uv/100; D2:=D shr 1;
  187.   for I:=1 to 120 do begin
  188.     Th:=90*(0.8+0.2*Sin(12*A))*(0.5+0.5*Sin(4*A));
  189.     XX[I]:=Trunc(Th*Cos(A));
  190.     YY[I]:=Trunc(Th*Sin(A));
  191.     A:=A+Pi/60;
  192.   end;
  193.   for Px:=1 to Un do
  194.     for Py:=1 to Un do begin
  195.       for I:=1 to 120 do begin
  196.     X:=Trunc(XX[I]*Sc)+Px*Uv-D2-K;
  197.     Y:=Trunc(YY[I]*Sc)+Py*Uv-D2-K;
  198.     Sq:=X*X+Y*Y;
  199.     if Sq<R*R then begin
  200.       if X<0 then S:=-1 else S:=1;
  201.       Th:=ArcTan(Y/(X+0.1));
  202.       M:=R*Sin(2*ArcTan(Sqrt(Sq)/R));
  203.       X:=S*Trunc(M*Cos(Th));
  204.       Y:=S*Trunc(M*Sin(Th));
  205.     end;
  206.     X:=X*23 div 15+Xc; Y:=Y*23 div 15+Yc;
  207.     if I=1 then begin MoveTo(X,Y); Bx:=X; By:=Y; end;
  208.     SetColor((120*(Px+Py)+I) div 42+32);
  209.     LineTo(X,Y);
  210.       end;
  211.       LineTo(Bx,By);
  212.     end;
  213. end;
  214. { ─────────────── Graph10 ─────────────── }
  215. procedure Graph10(Xc,Yc:integer;Rr:real);
  216. const Data:array[1..9] of integer=(7,436,245,17,775,180,31,1020,130);
  217. var Ste,Re,K,S,X,Y,Px,Py,Bx,By,I:integer;
  218.     A,AA,Ls,Di,R:real;
  219. begin
  220.   Px:=Xc; Py:=Yc; R:=50*Rr;
  221.   S:=8-Random(5);
  222.   if S mod 2=0 then K:=2 else K:=1;
  223.   A:=0; SetColor(32);
  224.   while A<=K*Pi+Pi/10/S do begin
  225.     X:=Trunc((R/4*Sin(3*S*A)+R*Sin(S*A))*Cos(A))+Px;
  226.     Y:=Trunc((R/4*Sin(3*S*A)+R*Sin(S*A))*Sin(A))+Py;
  227.     if A=0 then MoveTo(X,Y);
  228.     LineTo(X,Y);
  229.     A:=A+Pi/8/S;
  230.   end;
  231.   I:=0;
  232.   for Re:=1 to 3 do begin
  233.     Ste:=Data[3*Re-2]; Di:=Data[3*Re-1]/6*Rr; R:=Data[3*Re]/6*Rr;
  234.     if Re=2 then Ls:=(2*Pi/Ste)-0.1 else Ls:=0;
  235.     AA:=0;
  236.     while AA<=2*Pi-Ls do begin
  237.       Px:=Xc+Trunc(Di*Cos(AA));
  238.       Py:=Yc+Trunc(Di*Sin(AA));
  239.       S:=8-Random(5);
  240.       if S mod 2=0 then K:=2 else K:=1;
  241.       A:=0;
  242.       SetColor(I+33);
  243.       while A<=K*Pi+Pi/10/S do begin
  244.     X:=Trunc((R/4*Sin(3*S*A)+R*Sin(S*A))*Cos(A))+Px;
  245.     Y:=Trunc((R/4*Sin(3*S*A)+R*Sin(S*A))*Sin(A))+Py;
  246.     if A=0 then MoveTo(X,Y);
  247.     LineTo(X,Y);
  248.     A:=A+Pi/8/S;
  249.       end;
  250.       AA:=AA+2*Pi/Ste; I:=I+1;
  251.     end;
  252.   end;
  253.   A:=0; I:=0;
  254.   while A<=14*Pi do begin
  255.     X:=Xc+Trunc(Trunc(250*Rr)*(1+1/5*Sin(9.06*A))*Cos(A));
  256.     Y:=Yc+Trunc(Trunc(250*Rr)*(1+1/5*Sin(9.06*A))*Sin(A));
  257.     if A=0 then MoveTo(X,Y);
  258.     SetColor(I mod 72+32); LineTo(X,Y);
  259.     A:=A+Pi/60; I:=I+1;
  260.   end;
  261. end;
  262. { ─────────────── Ratio(Number) ─────────────── }
  263. function R(Num:integer):integer;
  264. begin
  265.   R:=Trunc(Num*Ratio);
  266. end;
  267. { ─────────────── Print ─────────────── }
  268. procedure Print(X,Y,Color,BkColor:integer;St:string);
  269. begin
  270.   Dec(Y,R(6));
  271.   SetColor(BkColor);
  272.   OutTextXY(X+1,Y+1,St);
  273.   SetColor(Color);
  274.   OutTextXY(X,Y,St);
  275.   OutTextXY(X+1,Y,St);
  276. end;
  277. { ─────────────── Screen ─────────────── }
  278. procedure Screen;
  279. const St:array[0..7] of string[24]=(
  280.     'SVGA/VESA 256 Colors','Graph Demo',
  281.     'Designed by Jou-Nan Chen','Rewritten in 1994',
  282.     'Arrow keys to select','Enter to show graph',
  283.     '* key to colorize','Esc to quit graph demo');
  284. var I:integer;
  285. begin
  286.   SetFillStyle(1,1);
  287.   Bar(0,R(400),R(640)-1,R(480)-1);
  288.   SetColor(11);
  289.   Rectangle(1,R(400)+1,R(640)-2,R(480)-2);
  290.   SetTextStyle(5,0,4);
  291.   SetUserCharSize(R(4),4,R(4),4);
  292.   for I:=0 to 7 do
  293.     Print(R(40),R(20)+R(40*I),64+3*I,4,St[I]);
  294.   for I:=0 to 9 do
  295.     Print(R(120)*(I mod 5)+R(20),R(32)*(I div 5)+R(400),64+3*I+120,0,Name[I]);
  296. end;
  297. { ─────────────── GraphMenu ─────────────── }
  298. procedure GraphMenu;
  299. var P,A,B:integer;
  300.     Ch:char;
  301. begin
  302.   Screen; P:=0;
  303.   repeat
  304.     SetFillStyle(1,104+120);
  305.     Bar(R(120)*(P mod 5)+R(12),R(32)*(P div 5)+R(407),R(120)*(P mod 5)+R(135),R(32)*(P div 5)+R(440));
  306.     Print(R(120)*(P mod 5)+R(20),R(32)*(P div 5)+R(400),64+3*P+120,0,Name[P]);
  307.     Ch:=ReadKey; if Ch=#0 then Ch:=ReadKey;
  308.     SetFillStyle(1,1);
  309.     Bar(R(120)*(P mod 5)+R(12),R(32)*(P div 5)+R(407),R(120)*(P mod 5)+R(135),R(32)*(P div 5)+R(440));
  310.     Print(R(120)*(P mod 5)+R(20),R(32)*(P div 5)+R(400),64+3*P+120,0,Name[P]);
  311.     case Ch of
  312.       #13:begin
  313.         SetFillStyle(1,0); Bar(0,0,R(640)-1,R(400)-1);
  314.         case P of
  315.           0:Graph1(R(320),R(200),R(250),R(100));
  316.           1:Graph2(R(280),R(245),R(160),R(40));
  317.           2:Graph3(R(320),R(195),R(80));
  318.           3:Graph4(R(320),R(195),R(80));
  319.           4:Graph5(R(320),R(200),R(120));
  320.           5:Graph6(R(85),R(45),R(28),R(90),R(62));
  321.           6:Graph7(R(320),R(200),R(200));
  322.           7:Graph8(R(320),R(200),R(200));
  323.           8:Graph9(R(320),R(200),R(245),R(100));
  324.           9:Graph10(R(320),R(200),0.6*Ratio);
  325.         end;
  326.         CirclePalette(32,72,72,30,Pal);
  327.       end;
  328.       'H':Dec(P,5); 'P':Inc(P,5);
  329.       'K':Dec(P);   'M':Inc(P);
  330.       '*':repeat CirclePalette(32,72,72,30,Pal); until KeyPressed=1;
  331.     end;
  332.     if P<0 then Inc(P,10); if P>9 then Dec(P,10);
  333.   until Ch=#27;
  334. end;
  335.  
  336. var A,B,C:integer;
  337.     Ch:char;
  338. begin
  339.   TextMode(Co80);
  340.   repeat
  341.     TextAttr:=$1B; ClrScr;
  342.     Writeln('   ▄▄▄▄▄  ▄▄▄▄▄');
  343.     Writeln('  █▒      █▒   █▒  SVGA/VESA Graph Demo');
  344.     Writeln('  █▒  ▀█▒ █▒▄▄▄▀   640x480--1024x768 256C');
  345.     Writeln('  █▒   █▒ █▒   █▒  Written by Jou-Nan Chen');
  346.     Writeln('   ▀▀▀▀   ▀    ▀');
  347.     TextAttr:=$1F;
  348.     Writeln('  Select a graph mode :');
  349.     TextAttr:=$1E;
  350.     Writeln('  (1)  640x480, 256 Colors');
  351.     Writeln('  (2)  800x600, 256 Colors');
  352.     Writeln('  (3) 1024x768, 256 Colors');
  353.     TextAttr:=$1F;
  354.     Write  ('  Enter your selection ? ');
  355.     Ch:=ReadKey; C:=Ord(Ch)-48;
  356.   until C in [1,2,3];
  357.   case C of
  358.     1:Ratio:=1;
  359.     2:Ratio:=1.25;
  360.     3:Ratio:=1.6;
  361.   end;
  362.   A:=InstallUserDriver('SVGA256',nil); B:=1+C;
  363.   InitGraph(A,B,'');
  364.   GetPalette(0,104,Pal); SetPalette(120,104,Pal);
  365.   GraphMenu;
  366.   CloseGraph;
  367.   RestoreCrtMode;
  368. end.
  369.